COMMENT ⊗   VALID 00004 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	CS306								 1986 Oct 27
C00009 00003	 lisp graph search using pseudo-car and friends
C00015 00004	In debugging programs involving circular list structures, commands like
C00016 ENDMK
C⊗;
CS306								 1986 Oct 27

;;; search.lsp[f86,jmc]	Lisp tree search program using pseudo-car and friends

;	There were a number of bugs in the search routines I discussed in
;class last week.  Rather than take more class time, I decided to make a
;handout with corrected versions.  There are also some extensions.  The
;programs search a tree (first page) or a graph (second page) for elements
;satisfying a predicate  p.  In the first case we give three functions.
;search[x,p]  returns the first node that satisfies  p  starting from the node
;x.  getall[x,p]  returns a list of all nodes satisfying  p.  singletons[x,p]
;is a list of those nodes satisfying  p  that occur exactly once.  This
;doesn't make sense for graphs in which a node is imagined to occur just
;once anyway.
;
;	All the nodes use the same basic functions.  These are
;based on regarding the tree or graph as a virtual list of nodes.
;The word virtual is used, because the actual list need not exist
;in the memory of the computer.  It is generated by repeated application
;of the function  successor  used to get the successors of a given node.
;The functions on virtual lists are the predicate  pn  corresponding to
;null,  and the functions  pa  and  pd  corresponding to  car  and  cdr.
;
;Here are the functions:
;
;search[x,p]  uses  pack  to creat a data structure and call  search1,
;which does the actual work.

(defun search (x p)
	(search1 (pack x) p))

(defun pack (x) (list x))

;search1[s,p]  is the recursive funtion that does the actual work.  It calls
;poke  first in order to share work that might otherwise be duplicated by
;pn,  pa  and  pd.

(defun search1 (s p)
       (let ((w (poke s)))
	    (cond ((pn w) 'lose)
		  ((funcall p (pa w)) (pa w))
		  (t (search1 (pd w) p)))))

; getall uses the same basic functions as search calling  getall1
;to do the recursive part.

(defun getall (x p) (getall1 (pack x) p nil))

(defun getall1 (s p u)
       (let ((w (poke s)))
	    (cond ((pn w) u)
		  ((funcall p (pa w)) (getall1 (pd w) p (cons (pa w) u)))
		  (t (getall1 (pd w) p u)))))

; Now we have  singletons  and  singletons1  as described above.
(defun singletons (x p) (singletons1 (pack x) p nil nil))

(defun singletons1 (s p ones twos)
       (let ((w (poke s)))
	    (cond ((pn w) ones)
		  ((funcall p (pa w))
		   (cond ((member (pa w) twos) (singletons1 (pd w) p ones twos))
			 ((member (pa w) ones) (singletons1 (pd w)
							    p
							    (delete (pa w) ones)
							    (cons (pa w) twos)))
			 (t (singletons1 (pd w) p (cons (pa w) ones) twos))))
		  (t (singletons1 (pd w) p ones twos)))))

; Here are the functions that depend on the actual structure.

(defun pn (w) (null w))

(defun pa (w) (car w))

(defun poke (s) s)

(defun pd (w) (append (successors (car w)) (cdr w)))


; The particular data structure determines  successors.
; The predicate being searched for is given as a parameter of the
; search functions.  Probably it would have been a good idea
; to make  successors  a parameter also.

; My somewhat unimaginative choice for the actual structure
; used in debugging took S-expressions as nodes, and  successors
; to a list of the  car  and  cdr  except in the atom case.
; This makes the debugging easy at the cost of not
; illustrating the generality of the concept.  Please
; apply your own imagination to restore the generality.

(defun successors (x) (if (atom x) nil (list (car x) (cdr x))))

(defun pfoo (x) (and (numberp x) (lessp x 2)))

;**
; Here are the tests that were used.

(search '((1 . 2) . 4) #'pfoo)

(search '((1 . 3) . 4) #'pfoo)


(setq a1 '((1 . 3) (1 . 4)))
(setq a2 '(2 3 0 3 1 0))

(getall a1 #'pfoo)
(getall a2 #'pfoo)
(getall 'a #'pfoo)

(singletons a1 #'pfoo)
(singletons a2 #'pfoo)
;;; lisp graph search using pseudo-car and friends

; The main difference between this and the tree search is that
; the data structure has as its  cdr  part a list of the nodes
; already seen, and  pd  skips by any node on this list.
(defun search (x p)
	(search1 (pack x) p))

(defun pack (x) (cons (list x) nil))

(defun search1 (s p)
       (let ((w (poke s)))
	    (cond ((pn w) 'lose)
		  ((funcall p (pa w)) (pa w))
		  (t (search1 (pd w) p)))))

(defun getall (x p) (getall1 (pack x) p nil))

(defun getall1 (s p u)
       (let ((w (poke s)))
	    (cond ((pn w) u)
		  ((funcall p (pa w)) (getall1 (pd w) p (cons (pa w) u)))
		  (t (getall1 (pd w) p u)))))

(defun pn (w) (null (car w)))

(defun pa (w) (caar w))

(defun poke (s) (if (or (null (car s)) (not (memq (caar s) (cdr s))))
		    s
		    (poke (cons (cdar s) (cdr s)))))

(defun pd (w) (let ((u (cons (caar w) (cdr w))))
		   (let ((v (subtractq (successors (caar w)) u)))
			(if (null v)
			    (poke (cons (cdar w) u))
			    (cons (append v (cdar w)) u)))))

(defun subtractq (u v) (cond ((null u) nil)
			    ((memq (car u) v) (subtractq (cdr u) v))
			    (t (cons (car u) (subtractq (cdr u) v)))))

(defun successors (x) (if (atom x) nil (list (car x) (cdr x))))

(defun pfoo (x) (and (numberp x) (lessp x 2)))

;**

(search '((3 . 2) . 4) #'pfoo)

(search '((3 . 1) . 4) #'pfoo)


(setq a1 '((1 . 3) (1 . 4)))
(setq a2 '(2 1 0 3 1 0))

(getall a1 #'pfoo)
(getall a2 #'pfoo)
(getall 'a #'pfoo)

; This is a dag that is not a tree.
(setq a3 (let ((x '(1 . 3))) (cons x x)))
(getall a3 #'pfoo)

; This creates a re-entrant list structure, but we need to be careful
; not to do anything that would result in trying to print it.
(setq a4 (list 'a 'b 'c 'a))
(null (rplacd (last a4) a4))

(search a4 #'pfoo)
(defun pfoo1 (x) (eq x 'a))
(search a4 #'pfoo1)
(getall a4 #'pfoo1)
;In debugging programs involving circular list structures, commands like
;the following will prevent trace, etc. from running out of push down list
;in a vain attempt to print the infinite trees corresponding to circular
;list structures.

(setq prinlevel 6)   ;init nil
(setq prinlength 6)  ;init nil